home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH3 / SRC / MKFONT.FRM < prev    next >
Text File  |  1996-04-19  |  4KB  |  125 lines
  1. VERSION 4.00
  2. Begin VB.Form MkFontForm 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00FFFFFF&
  5.    Caption         =   "MkFont"
  6.    ClientHeight    =   5505
  7.    ClientLeft      =   2040
  8.    ClientTop       =   930
  9.    ClientWidth     =   5040
  10.    Height          =   6195
  11.    Left            =   1980
  12.    LinkTopic       =   "Form1"
  13.    ScaleHeight     =   275.25
  14.    ScaleMode       =   2  'Point
  15.    ScaleWidth      =   252
  16.    Top             =   300
  17.    Width           =   5160
  18.    Begin VB.Menu mnuFile 
  19.       Caption         =   "&File"
  20.       Begin VB.Menu mnuFileExit 
  21.          Caption         =   "E&xit"
  22.       End
  23.    End
  24. End
  25. Attribute VB_Name = "MkFontForm"
  26. Attribute VB_Creatable = False
  27. Attribute VB_Exposed = False
  28. Option Explicit
  29.  
  30. ' ***********************************************
  31. ' Draw a text string at the indicated position
  32. ' using the indicated font.
  33. ' ***********************************************
  34. Sub DrawText(txt As String, X As Single, Y As Single, nHeight As Long, nWidth As Long, nEscapement As Long, fnWeight As Long, fbItalic As Long, fbUnderline As Long, fbStrikeOut As Long, fbCharSet As Long, fbOutputPrecision As Long, fbClipPrecision As Long, fbQuality As Long, fbPitchAndFamily As Long, lpszFace As String)
  35. Dim newfont As Long
  36. Dim oldfont As Long
  37.  
  38.     newfont = CreateFont(nHeight, nWidth, nEscapement, 0, fnWeight, fbItalic, fbUnderline, fbStrikeOut, fbCharSet, fbOutputPrecision, fbClipPrecision, fbQuality, fbPitchAndFamily, lpszFace)
  39.     oldfont = SelectObject(hdc, newfont)
  40.  
  41.     CurrentX = X
  42.     CurrentY = Y
  43.     Print txt
  44.     
  45.     newfont = SelectObject(hdc, oldfont)
  46.     If DeleteObject(newfont) = 0 Then
  47.         Beep
  48.         MsgBox "Error deleting font object.", vbExclamation
  49.     End If
  50. End Sub
  51.  
  52.  
  53.  
  54.  
  55.  
  56. ' ************************************************
  57. ' Draw an assortment of text samples.
  58. ' ************************************************
  59. Sub DrawTheText()
  60. Dim X As Single
  61. Dim Y As Single
  62. Dim R As Single
  63. Dim i As Long
  64. Dim theta As Long
  65. Dim pt As Long
  66. Dim fnt As String
  67. Dim ang As Single
  68.  
  69.     MousePointer = vbHourglass
  70.     DoEvents
  71.     Cls
  72.     
  73.     ' Different weights.
  74.     X = 10
  75.     CurrentY = 0
  76.     pt = 15
  77.     fnt = "Times New Roman"
  78.     For i = 0 To 900 Step 100
  79.         DrawText "Weight" & Str$(i), X, CurrentY, pt, 0, 0, i, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  80.     Next i
  81.     
  82.     ' Tall, thin characters.
  83.     X = 85
  84.     Y = 0
  85.     i = 5
  86.     For pt = 15 To 55 Step 10
  87.         DrawText Format$(pt) & "x" & Format$(i), X, Y, pt, i, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  88.         Y = Y + pt * 0.5
  89.     Next pt
  90.  
  91.     ' Short, wide characters.
  92.     X = 135
  93.     pt = 15
  94.     CurrentY = 0
  95.     For i = 3 To 20 Step 3
  96.         DrawText Format$(pt) & "x" & Format$(i), X, CurrentY, pt, i, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  97.     Next i
  98.     
  99.     ' Rotated characters.
  100.     pt = 15
  101.     X = 160
  102.     Y = 185
  103.     For theta = 360 To 3600 Step 360
  104.         DrawText "     Escapement" & Str$(theta), X, Y, pt, 0, theta, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  105.     Next theta
  106.     theta = 0
  107.     DrawText "Escapement" & Str$(theta), 10, 250, pt, 0, theta, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  108.     theta = 3600
  109.     DrawText "Escapement" & Str$(theta), 10, CurrentY, pt, 0, theta, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
  110.  
  111.     MousePointer = vbDefault
  112. End Sub
  113.  
  114.  
  115. Private Sub Form_Load()
  116.     DrawTheText
  117. End Sub
  118.  
  119.  
  120. Private Sub mnuFileExit_Click()
  121.     Unload Me
  122. End Sub
  123.  
  124.  
  125.